home *** CD-ROM | disk | FTP | other *** search
/ CU Amiga Super CD-ROM 27 / CU Amiga Magazine's Super CD-ROM 27 (1998)(EMAP Images)(GB)[!][issue 1998-10].iso / CUCD / Programming / JForth / Extras / ODE / obj_object < prev    next >
Encoding:
Text File  |  1992-01-14  |  6.3 KB  |  273 lines
  1. \ Basic Classes of Object, Integer and Array.
  2. \
  3. \ Author: Phil Burk
  4. \ Copyright 1986 Delta Research
  5. \
  6. \ MOD: PLB 6/29/86 Clear OB-PNTR in INIT:, use INIT: SUPERs
  7. \ MOD: PLB 7/03/86 Do FREE: in NEW: , FREE: only if allocated.
  8. \ MOD: PLB 7/14/86 Add USE.DICT: method., changed OB-#ELEMS to OB-#CELLS
  9. \ MOD: PLB 7/16/86 Fixed bug introduced by last mod, WARRAY & ARRAY
  10. \      weren't using INIT: SUPER and so weren't initing OB-USE-DICT
  11. \      to false.  Therefore lot's of things were getting allocated
  12. \      in the dictionary!
  13. \ MOD: PLB 7/26/86 Added STUFF: method.
  14. \ MOD: PLB 7/27/86 Added ?DUP IF to INDEXOF: to fix size=0 bug.
  15. \                  Moved INDEXOF: from ELMNTS.
  16. \ MOD: PLB 7/29/86 Added OB.REPORT for object error reporting.
  17. \ MOD: PLB 9/12/86 Added GET.NAME: and PUT.NAME: and +TO:
  18. \ MOD: PLB 10/12/86 Changed to new OB.IVAR to IV.LONG system.
  19. \ MOD: PLB 10/13/86 Vectored AT: and TO: to allow width changes.
  20. \ MOD: PLB 11/21/86 Added width:
  21. \ MOD: PLB 12/3/86  Put AR.SELECT.CFA in NEW: for MAC
  22. \ MOD: PLB 1/20/87  Change EVENUP.DP to ALIGN
  23. \ MOD: PLB 1/21/87 Added INSTANTIATE and DEINSTANTIATE
  24. \ MOD: PLB 2/10/87 Added 0 iv=> iv-#cells to FREE:
  25. \ MOD: PLB 2/13/87 Added EXTEND: method.
  26. \ MOD: PLB 2/19/87 Added EMPTY: stub.  , use MM.ZALLOC
  27. \ MOD: PLB 4/2/87  Added USE->REL to OS.DUMP, changed order.
  28. \ MOD: PLB 11/16/87 Add RUN.FASTER and RUN.SAFER
  29. \          Put CR before name in PRINT:
  30. \ MOD: PLB 11/17/87 Added USE->REL to <INSTANTIATE>,
  31. \          0 out object when DEINSTANTIATEd to prevent
  32. \          continued use.
  33. \ MOD: PLB 12/15/87 EXTEND: now does a NEW: if no data.
  34. \ MOD: PLB 9/13/88 Allow INSTANTIATE to pass params to INIT:
  35. \ MOD: PLB 10/4/89 Add CLASS check to <instantiate>.
  36. \ MOD: PLB 11/8/89  Remove USE->REL stuff from INSTANTIATE
  37. \ MOD: PLB 12/15/89 Add }stuff: and }NEWStuff:
  38. \ MOD: PLB 5/17/91 Split OBJ_ARRAY into OBJ_OBJECT & OBJ_ARRAY
  39.  
  40. ANEW TASK-OBJ_OBJECT
  41.  
  42. ( declare methods for object, define OBJECT class )
  43. METHOD ADDRESS:
  44. METHOD SPACE:
  45. METHOD DUMP:
  46. METHOD NAME:
  47. METHOD PUT.NAME:
  48. METHOD GET.NAME:
  49. METHOD .CLASS:
  50.  
  51. :CLASS OBJECT   ( root class )
  52.     IV.LONG IV-NAME  ( This must always be the first IVAR )
  53.  
  54. :M INIT:  ( setup object )
  55.     0 iv=> iv-name
  56. ;M
  57.  
  58. :M ADDRESS:  ( -- addr , leave address of object )
  59.     os.copy
  60. ;M
  61.  
  62. :M SPACE: ( -- NBYTES , size of ivariable space )
  63.     os.copy  ob.obj->class ( point to base of class )
  64.     @
  65. ;M
  66.  
  67. :M DUMP: ( -- , hex dump ivars )
  68.     os.copy space: self  dump
  69. ;M
  70.  
  71. :M GET.NAME: ( -- $name , put name of object on pad as string )
  72.     iv-name ?dup 0=
  73.     IF address: self pfa->nfa nfa->$
  74.     ELSE dup c@ 31 >
  75.         IF nfa->$
  76.         THEN
  77.     THEN
  78. ;M
  79.  
  80. :M NAME: ( -- , print name of object )
  81.     get.name: self $.
  82. ;M
  83.  
  84. \ Object Error Reporting -----------------------------------
  85. : OS.DUMP ( -- , Show objects on OBJECT-STACK )
  86.     >newline ." Object Stack --------" cr
  87.     os.depth 0
  88.     DO  os.depth i - 1- os.pick
  89.         use->rel 4 spaces name: [] cr
  90.     LOOP
  91. ;
  92.  
  93. : OB.REPORT.ERROR  ( $word $message level -- , report error in object )
  94.     os.dump
  95.     dup er_fatal =    IF os.sp! THEN
  96.     er.report
  97. ;
  98.  
  99. :M PUT.NAME: ( $name -- , put name of object in object )
  100.     iv=> iv-name
  101. ;M
  102.  
  103. :M .CLASS: ( -- , print class of object )
  104.     address: self ob.obj->class
  105.     pfa->nfa id.
  106. ;M
  107.  
  108. ;CLASS
  109.  
  110. variable DYNOBJ-COUNT
  111.  
  112. : <###> ( 0-999 -- addr count , make string with leading zeros )
  113.     s->d <# # # # #>
  114. ;
  115.  
  116. \ Support the dynamic allocation of an object.
  117. 32 constant OBJ_NAME_SIZE
  118. :STRUCT  OBJ_DYN_HEADER  \ Dynamic Header for Object
  119.     Struct DoubleList odh_node
  120.     OBJ_NAME_SIZE bytes odh_name
  121.     4 bytes odh_object
  122. ;STRUCT
  123.  
  124. DoubleList OBJ-DYN-LIST  \ list of dynamically alloced objs
  125.  
  126. : OBJ.OBJ>DH  ( dynamic_object -- dynamic_header )
  127.     odh_object -
  128. ;
  129. : OBJ.DH>OBJ  ( dynamic_header -- dynamic_object)
  130.     odh_object +
  131. ;
  132.  
  133. : ODH.INIT obj-dyn-list dll.newlist ;
  134.  
  135. : OB.INIT  ob.init odh.init ;
  136. : AUTO.INIT  auto.init odh.init ;
  137.  
  138. : OBJ.FIND.DYN  { $name | rel_obj -- rel_obj true | false }
  139.     0 -> rel_obj
  140.     obj-dyn-list dll.first
  141.     BEGIN
  142.         dup dll.end? not
  143.         IF
  144.             dup .. odh_name $name
  145.             $equal
  146.             IF
  147.                 dup obj.dh>obj use->rel -> rel_obj true
  148.             ELSE
  149.                 dll.next false
  150.             THEN
  151.         ELSE true
  152.         THEN
  153.     UNTIL drop
  154.     rel_obj ?dup 0= 0=
  155. ;
  156.  
  157. : 'O ( <name> -- rel_obj , return relative object )
  158.     bl word
  159.     obj.find.dyn 0= abort" Couldn't find dynamic object!"
  160. ;
  161.  
  162. : OBJ.LIST.DYN  ( -- )
  163.     >newline
  164.     obj-dyn-list dll.first
  165.     BEGIN
  166.         dup dll.end? not
  167.     WHILE
  168.         dup .. odh_name 4 spaces $type cr?
  169.         dll.next
  170.     REPEAT
  171.     drop
  172. ;
  173.  
  174. : <?INSTANTIATE> ( pfa_class --  rel_addr_object | 0 , instantiate class )
  175.     dup ob.check.class
  176.     dup >r @ ( -- size )
  177.     odh_object + ( make room for fake name and node)
  178.     mm.zalloc? ?dup
  179.     IF
  180.         dup obj-dyn-list dll.add.head
  181.         r> ( -- dynheader class )
  182.         over >r
  183.         swap .. odh_object swap  \ convert to object address
  184.         ob.setup ( use return stack to allow passing to INIT: )
  185. \
  186. \ Store unique name in OBJ_NAME_SIZE bytes before object.
  187.         " DYN" r@ .. odh_name $move
  188.         dynobj-count @ 1+ dup dynobj-count ! <###>  ( addr count )
  189.         r@ .. odh_name $append
  190.         r@ .. odh_name
  191.         r> obj.dh>obj use->rel tuck put.name: []
  192.     ELSE
  193.         rdrop 0
  194.     THEN
  195. ;
  196.  
  197. : <INSTANTIATE> (  pfa_class --  rel_addr_object | ABORT )
  198.     <?instantiate>
  199.     dup 0= abort" <INSTANTIATE> - insufficient memory!"
  200. ;
  201.  
  202. : INSTANTIATE ( <class> -- addr_object | abort , instantiate class )
  203.     bl word find
  204.     IF ( -- cfa )
  205.         >body
  206.         state @
  207.         IF [compile] aliteral compile <instantiate>
  208.         ELSE <instantiate>
  209.         THEN
  210.     ELSE ( -- name )
  211.         >newline $type cr
  212.         " INSTANTIATE" " Class could not be found!"
  213.         er_fatal er.report
  214.     THEN
  215. ; IMMEDIATE
  216.  
  217. : ?INSTANTIATE ( <class> -- addr_object | 0 , instantiate class )
  218.     bl word find
  219.     IF ( -- cfa )
  220.         >body
  221.         state @
  222.         IF [compile] aliteral compile <?instantiate>
  223.         ELSE <?instantiate>
  224.         THEN
  225.     ELSE ( -- name )
  226.         >newline $type cr
  227.         " ?INSTANTIATE" " Class could not be found!"
  228.         er_fatal er.report
  229.     THEN
  230. ; IMMEDIATE
  231.  
  232. : DEINSTANTIATE ( rel_addr_object -- , Deallocate an object )
  233.     rel->use
  234.     0 over !  ( clear class pointer to disable object )
  235.     obj.obj>dh dup dll.remove mm.free
  236. ;
  237.  
  238. \ define OB.INT class --------------------------------------
  239. METHOD CLEAR:
  240. METHOD GET:
  241. METHOD PUT:
  242. METHOD PRINT:
  243. METHOD +:
  244.  
  245. :CLASS OB.INT <SUPER OBJECT
  246.     IV.LONG IV-INT-DATA
  247.  
  248. :M CLEAR: ( -- , set to zero )
  249.     0 iv=> iv-int-data
  250. ;M
  251.  
  252. :M INIT:  ( -- , setup )
  253.     clear: self
  254. ;M
  255.  
  256. :M GET:  ( -- value , fetch )
  257.     iv-int-data
  258. ;M
  259.  
  260. :M PUT: ( value -- , store )
  261.     iv=> iv-int-data
  262. ;M
  263.  
  264. :M PRINT: ( -- , show data )
  265.     cr get: self . cr
  266. ;M
  267.  
  268. :M +: ( value -- , add to contents )
  269.     iv+> iv-int-data
  270. ;M
  271. ;CLASS
  272.  
  273.